Transactor/Transactor_11_1986_Transactor_Publishing.d64/pop menu source

Commodore BASIC | 2023-02-26 | 12KB | 561 lines

5 sys 700
6 .opt oo
10 ;*********************************
20 ;** window and pop menu manager **
30 ;**   by darren james spruyt    **
40 ;**                             **
50 ;**(c) 1985 by                  **
60 ;**         darren james spruyt **
90 ;*********************************
1000 ;define variables
1010 *=$c000
1015 lpickarea =$02
1020 xby4  =$0256
1030 yby4  =$0255
1040 avail =$0258
1050 line  =$0257
2000 start =*
2010 jmp tsprite     ;pick areas on
2020 jmp anpickarea  ;add new pick area
2025 jmp popmenu     ;pop menu
2030 jmp dpickarea   ;delete pick area
2040 jmp pareasoff   ;pick areas off
5000 f1 rts
10000 popmenu =*         ;popmenu entry
10002 ldy #0
10004 jsr getval         ;get four
10006 bmi f1             ;parameters
10008 lda pickheight     ;for input
10009 cmp #3             ;and check
10010 bcc f1             ;for minimum
10011 lda pickwidth      ;width and
10012 cmp #3             ;height
10013 bcc f1
10014 sty avail          ;set avail flg
10016 jsr getparam
10018 stx color          ;get color
10020 jsr $aefd          ;check comma
10022 jsr $ad9e          ;eval input
10024 ldy $65
10026 lda $64
10028 jsr $b6db          ;cln desc stk
10030 ldy #2
10032 lda ($64),y
10034 sta $48            ;get add hi
10036 dey
10038 lda ($64),y
10040 sta $47            ;get add lo
10050 lda $47
10052 bne en0            ;dec address
10054 dec $48            ;by one
10056 en0 dec $47        ;
10090 lda #0
10100 jsr copy1          ;copy section
10200 ldy #0
10210 jsr makep          ;make pntr
10220 ldx pickheight
10225 jsr colorline
10230 ldy pickwidth
10240 dey
10250 lda #$6e           ;"[174]"
10260 sta ($fb),y
10270 dey
10272 bmi en1
10280 lda #$40           ;"[192]"
10290 en2 sta ($fb),y
10300 dey
10302 bmi en1
10310 bne en2
10320 lda #$70           ;"[176]"
10330 sta ($fb),y
10340 en1 stx temp
10350 en1a lda #$28      ;
10360 ldx #$fb           ;
10370 jsr add            ;increase pntr
10375 jsr colorline
10380 ldx temp           ;line cntr
10390 dex
10400 beq en3            ;exit if done
10402 cpx #1             ;
10404 beq en6
10410 ldy #0
10420 lda #$5d           ;"[221]"
10430 sta ($fb),y
10440 en4 iny
10450 cpy pickwidth
10460 beq en5
10470 lda ($47),y        ;get char
10475 jsr corrascii
10480 sta ($fb),y        ;to screen
10490 jmp en4
10500 en5 dey
10510 lda #$5d           ;"[221]"
10515 sta ($fb),y
10520 stx temp
10530 lda pickwidth
10540 sec
10550 sbc #$02
10560 ldx #$47
10570 jsr add            ;inc pntr
10580 jmp en1a
10640 en6 ldy pickwidth  ;
10650 dey
10660 lda #$7d           ;"[189]"
10670 sta ($fb),y
10680 lda #$40           ;"[192]"
10690 en8 dey
10700 beq en7
10710 bmi en3
10720 sta ($fb),y
10730 jmp en8
10740 en7 lda #$6d       ;"[173]"
10750 sta ($fb),y
10760 ;
10800 en3 ldx #1         ;set to top
10810 ep3 jsr revline
10900 ep2 stx temp       ;save line
10905 jsr $ffe4          ;get char
10907 ldx temp
10910 cmp #"[145]            ;up?
10920 bne ep1
10930 ;up
10940 cpx #1             ;at [164]p[153]
10950 beq ep2            ;yes
10960 jsr revline        ;unrevrs line
10970 dex
10980 jmp ep3            ;up 1
11000 ep1 cmp #"        ;down?
11010 bne ep4
11012 txa
11014 clc
11016 adc #2
11020 cmp pickheight     ;at bottom
11030 beq ep2            ;yes
11040 jsr revline        ;unrevrs line
11050 inx
11060 jmp ep3            ;increase line
11100 ep4 cmp #$0d       ;is a return
11110 bne ep2            ;nope
11120 stx $0257          ;set line num
11130 lda #$80           ;copy back
11140 jsr copy1          ;data to sc
11150 lda #1             ;release pntr
11160 sta avail
11170 rts                ;back to basic
11499 ;
11500 colorline =*
11510 ldy pickwidth
11520 jsr imagepntrs     ;backup pntrs
11530 dey
11540 lda color          ;set line
11550 cl1 sta ($fd),y    ;according
11560 dey
11570 bpl cl1            ;finish
11580 rts
12000 copy1 sta dir
12005 lda #0             ;set ($22) to
12010 sta $22
12020 lda #$b0           ;$b000
12030 sta $23
12032 ldy #0
12034 jsr makep          ;make address
12040 lda $01
12050 and #%11111110
12060 sei                ;lock irqs
12070 sta $01            ;open the rom
12080 jsr imagepntrs
12100 ;transfer from ($fb) to ($22)
12110 ldx pickheight
12115 ep9 ldy pickwidth
12120 dey
12122 epb lda dir
12124 bpl epa
12126 lda ($22),y    ;copy from memory
12127 sta ($fb),y    ;to screen
12128 lda ($24),y
12129 sta ($fd),y
12130 jmp ep8
12132 epa lda ($fb),y;copy from screen
12134 sta ($22),y    ;to memory
12136 lda ($fd),y
12138 sta ($24),y
12150 ep8 dey
12160 bpl epb        ;finish line
12200 ;inc pntrs
12210 stx temp
12220 lda #$28       ;add $28 to $fb
12230 ldx #$fb
12240 jsr add
12250 lda #$28       ;add $28 to $fb
12260 ldx #$22
12270 jsr add
12275 jsr imagepntrs ;copy pntrs
12280 ldx temp
12290 dex
12300 bne ep9        ;finish all lines
12310 lda $01
12320 ora #%00000001
12330 sta $01        ;close roms
12340 cli
12400 rts            ;and finish up
12900 imagepntrs =*
12905 lda $22        ;backup ($22) to
12910 sta $24
12915 lda $23
12920 ora #$04
12925 sta $25        ;($24)
12930 lda $fb        ;backup ($fb) to
12935 sta $fd
12940 lda $fc
12945 and #$03
12950 ora #$d8
12955 sta $fe        ;($fd)
12960 rts
13000 revline  =*
13020 ldy #0         ;
13030 txa            ;.x holds line
13032 sta temp
13040 clc
13050 adc pareay     ;add pick offset
13055 tax
13060 jsr makep1     ;make pntr
13070 ldy pickwidth  ;get width of line
13080 dey
13082 dey
13090 rvl1 lda ($fb),y
13100 eor #$80       ;reverse char
13110 sta ($fb),y    ;back to sc
13120 dey
13130 bne rvl1       ;finish line
13135 ldx temp       ;restore .x
13140 rts
14999 ;
15000 dpickarea =*
15010 jsr getparam   ;get pick are
15020 cpx #17
15030 bcs ep7        ;error so exit
15050 lda #0
15060 sta pareasopen,x;delete with 0
15070 rts            ;done
15080 ep7 lda #$ff   ;error return
15090 rts
15989 ;
15999 pareasoff =*   ;turn areas off
16000 lda $d015
16010 and #%01111111
16020 sta $d015      ;turn of sprite
16030 sei
16040 lda #$ea
16050 sta $0315      ;reset irq
16060 lda #$31
16070 sta $0314      ;vector and
16080 cli
16090 rts            ;exit
16999 ;
19000 add =*         ;add routine
19010 clc
19020 adc $00,x      ;add value in .a
19030 sta $00,x
19040 bcc add1       ;to indirect
19050 inc $01,x
19060 add1 rts       ;at $00,x
19069 ;
19100 corrascii =*   ;correct ascii
19110 cmp #$40
19120 bcc cr1        ;characters
19130 sbc #$40
19140 cr1 cmp #$80   ;before placing
19150 bcc cr2
19160 sbc #$40       ;on the screen
19170 cr2 rts
19999 ;
20000 anpickarea =*
20010 ldy #16
20014 an0 lda pareasopen,y
20016 beq an1
20020 dey
20022 bne an0
20040 lda #$fe
20060 ep6    rts
20100 an1 =*
20110 jsr getval
20120 bmi ep6
20130 sta pareasopen,y
20140 rts
20200 getval jsr getparam
20210 cmp #40
20220 bcs error
20230 sta pareax,y
20240 jsr getparam
20250 cmp #25
20260 bcs error
20270 sta pareay,y
20280 jsr getparam
20285 beq error
20290 sta pickwidth,y
20292 clc
20294 adc pareax,y
20296 cmp #40
20298 bcs error
20300 jsr getparam
20305 beq error
20307 sta pickheight,y
20310 clc
20312 adc pareay
20314 cmp #25
20316 bcs error
20320 lda #1
20340 rts
20350 error =*
20360 lda #$ff
20380 rts
29000 irqentry =*
29100 lda #>retcall      ;
29110 pha
29120 lda #<retcall      ;set fake irq
29130 pha
29140 php                ;call data
29150 pha
29160 pha
29170 pha
29200 jmp $ea31          ;do irq
29500 retcall =*         ;back here
29510 lda avail          ;is ok
29520 bne rr1            ;yes
29530 ex1 jmp $febc      ;finish irq
29600 rr1 lda $9d        ;in basic
29610 bmi ex1            ;nope
29612 lda $cc            ;cursor on
29614 beq ex1            ;yes - exit
29620 ldy $c6
29630 lda $0276,y        ;get last chr
29640 ldx #3
29650 af0 cmp tablea,x   ;check against
29660 beq af1            ;table
29670 dex
29680 bpl af0
29690 bmi af2
29700 af1  dec $c6       ;delete from
29710 af2  lda $cb       ;buffer + get
29720 cmp #$07
29730 beq af3
29740 cmp #$02
29750 bne ex1
29760 af3 and #$01
29763 ldy $028d
29765 beq cup
29770 cpy #3
29780 bcs ex1
29790 ora #$02
29800 jmp cup
30100 cup cmp #03        ;up
30110 bne cdown
30130 ldy ypos
30140 beq end            ;at top - ex
30145 dey
30150 sty ypos           ;decrease
30160 jmp end
30200 cdown cmp #1       ;down
30210 bne cleft
30230 ldy ypos
30240 cpy #99
30250 bcs end            ;at bottom -ex
30260 iny
30270 sty ypos           ;increase
30280 jmp end
30300 cleft cmp #02      ;left
30310 bne cright
30320 ;left
30330 ldy xpos
30340 beq end            ;at left - ex
30345 dey
30350 sty xpos           ;decrease
30360 jmp end
30400 cright cmp #00     ;right
30410 bne end
30420 ;right
30430 ldy xpos
30440 cpy #159           ;at right-ex
30450 bcs end
30460 iny
30470 sty xpos           ;increase
30500 end   =*
30510 lda $d010
30520 and #%01111111
30530 sta $d010          ;zero high bit
30540 lda xpos
30550 asl
30560 bcc ck6            ;x *2
30565 jsr setbit         ;set if ness.
30570 ck6 clc
30580 adc #24
30590 bcc ck7            ;add offset
30600 jsr setbit         ;set if ness.
30610 ck7 sta $d00e      ;set lo byte
30620 lda ypos           ;get ypos
30630 asl
30640 adc #50
30650 sta $d00f          ;set it
31000 lda xpos
31010 lsr
31020 lsr                ;/ xpos by 4
31030 sta xby4           ;to yield char
31040 lda ypos           ;positions
31050 lsr
31060 lsr                ;/ ypos by 4
31070 sta yby4           ;as above
31102 ldy #16            ;
31104 ck4 lda pareasopen,y
31105 beq ck3
31110 lda xby4
31120 cmp pareax,y
31130 bcc ck3            ;to the left
31150 sbc pareax,y
31160 cmp pickwidth,y
31170 bcs ck3            ;to the right
31180 lda yby4
31190 cmp pareay,y
31200 bcc ck3            ;above area
31210 sbc pareay,y
31220 cmp pickheight,y
31230 bcs ck3            ;below bottom
31240 cpy lpickarea      ;was last
31250 beq ck1            ;yes - no prob
31260 sty temp1          ;save new on
31270 ldy lpickarea      ;reverse last
31280 jsr revarea        ;pick area
31290 ldy temp1          ;get new area
31300 sty lpickarea      ;store cur pic
31310 jsr revarea        ;reverse area
31320 ck1 jmp $febc      ;exit irq
31350 ck3 dey            ;do all
31370 bne ck4            ;open picks
31380 ldy lpickarea      ;if none revrs
31390 jsr revarea        ;last area
31400 lda #0
31410 sta lpickarea      ;set to 0
31420 jmp $febc          ;done irq
31999 ;
32000 revarea  =*        ;
32002 tya
32004 beq dn1
32020 jsr makep          ;make pntr
32120 ldx pickheight,y
32130 lda pickwidth,y
32140 sta temp
32145 dec temp
32150 rv0 ldy temp
32160 rv1 lda ($fb),y   ;get char
32170 eor #$80          ;reverse
32180 sta ($fb),y       ;back to sc
32190 dey
32200 bpl rv1           ;finish line
32210 lda $fb
32220 clc
32230 adc #$28
32240 sta $fb
32250 bcc rv2
32260 inc $fc           ;increase pntr
32270 rv2 dex
32280 bne rv0           ;finish lines
32290 dn1 rts
38000 makep =*          ;make pointer
38010 ldx pareay,y
38020 makep1 lda $d9,x  ;at ($fb),
38030 and #$03
38040 ora $0288         ;to point
38050 sta $fc
38060 lda $ecf0,x       ;to screen line
38070 clc
38080 adc pareax,y      ;according to
38090 sta $fb
38100 bcc pn1           ;pick area in
38110 inc $fc
38120 pn1 rts           ;.y
39000 setbit =*         ;set msb of
39005 pha
39010 lda $d010         ;sprite pos
39020 ora #%10000000
39030 sta $d010
39035 pla
39040 rts
40000 tsprite =*        ;copy sprite
40010 ldy #63
40020 ts1 lda spritedata,y
40030 sta $03c0,y       ;to low memory
40040 dey
40050 bpl ts1
41010 sei               ;lock irq's
41020 lda #>irqentry
41030 sta $0315
41040 lda #<irqentry
41050 sta $0314         ;set vector
41060 cli
41100 lda #128
41110 sta 53248+21      ;turn on
41120 lda #15
41130 sta $07ff         ;set pic loc
41135 sta avail         ;set avail flg
41140 lda #0
41150 sta pareasopen    ;zero open
41152 sta lpickarea     ;set last pick
41154 sta xpos
41156 sta ypos          ;start pos
41160 lda #0
41170 ldy #16           ;clear flags
41180 ts2 sta pareasopen,y
41190 dey
41200 bpl ts2           ;for pick areas
41210 lda #24
41220 sta $d00e         ;set start
41230 lda #50
41240 sta $d00f
41410 rts               ;sprite pos
42000 getparam  =*
42010 sty temp
42020 jsr $aefd         ;check comma
42030 jsr $b79e         ;0-255 parameter
42040 ldy temp
42050 txa               ;return in .a
42060 rts
50000 spritedata =*
50010 .byte%11111110,%00000000,%00000000
50020 .byte%11100000,%00000000,%00000000
50030 .byte%11110000,%00000000,%00000000
50040 .byte%11011000,%00000000,%00000000
50050 .byte%11001100,%00000000,%00000000
50060 .byte%11000110,%00000000,%00000000
50070 .byte%00000011,%00000000,%00000000
50080 .byte%00000001,%00000000,%00000000
50100 .byte 0,0,0
50110 .byte 0,0,0
50120 .byte 0,0,0
50130 .byte 0,0,0
50140 .byte 0,0,0
50150 .byte 0,0,0
50160 .byte 0,0,0
50170 .byte 0,0,0
50180 .byte 0,0,0
50190 .byte 0,0,0
50200 .byte 0,0,0
50210 .byte 0,0,0
50220 .byte 0,0,0
50500 tablea .byte $11,$1d,$91,$9d
60000 ;internal variables
60010 ypos *=*+1
60030 xpos *=*+1
60050 pareasopen =*
60060 .byte 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
60080 pareax =*
60090 .byte 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
60100 pareay =*
60110 .byte 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
60120 pickwidth =*
60130 .byte 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
60140 pickheight =*
60150 .byte 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
60200 temp *=*+1
60220 dir  *=*+1
60240 temp1 *=*+1
60500 color *=*+1